Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/ddevb/dde_vb.frm

Visual Basic Form | 1995-09-06 | 20.4 KB | 636 lines

VERSION 2.00
Begin Form DDE_VB
   BackColor       =   &H00FFFFFF&
   BorderStyle     =   3  'Fixed Double
   Caption         =   "DDE_VB"
   ClientHeight    =   4950
   ClientLeft      =   1020
   ClientTop       =   2520
   ClientWidth     =   7575
   Height          =   5640
   Icon            =   DDE_VB.FRX:0000
   Left            =   960
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   4950
   ScaleWidth      =   7575
   Top             =   1890
   Width           =   7695
   Begin TextBox tbStatus
      FontBold        =   -1  'True
      FontItalic      =   -1  'True
      FontName        =   "MS Sans Serif"
      FontSize        =   8.25
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   360
      Left            =   0
      TabIndex        =   14
      Top             =   4608
      Width           =   7596
   End
   Begin CommandButton cmClipboard
      Caption         =   "Clipboard"
      Height          =   276
      Left            =   6240
      TabIndex        =   17
      Top             =   4128
      Width           =   1236
   End
   Begin TextBox tbDDE
      Height          =   372
      Left            =   6240
      MultiLine       =   -1  'True
      TabIndex        =   12
      Top             =   2208
      Visible         =   0   'False
      Width           =   1236
   End
   Begin TextBox tbText
      Height          =   2220
      Left            =   96
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   13
      Top             =   2208
      Width           =   6036
   End
   Begin CommandButton cmPoke
      Caption         =   "Poke"
      Height          =   276
      Left            =   6240
      TabIndex        =   16
      Top             =   1728
      Width           =   1236
   End
   Begin ComboBox cbPoke
      Height          =   288
      Left            =   96
      TabIndex        =   15
      Top             =   1728
      Width           =   6036
   End
   Begin CommandButton cmExecute
      Caption         =   "Execute"
      Enabled         =   0   'False
      Height          =   276
      Left            =   6240
      TabIndex        =   9
      Top             =   1344
      Width           =   1236
   End
   Begin ComboBox cbExecute
      Enabled         =   0   'False
      Height          =   288
      Left            =   96
      TabIndex        =   3
      Top             =   1344
      Width           =   6036
   End
   Begin CommandButton cmDisconnect
      Caption         =   "Disconnect"
      Height          =   276
      Left            =   6240
      TabIndex        =   5
      Top             =   864
      Visible         =   0   'False
      Width           =   1236
   End
   Begin TextBox tbError
      ForeColor       =   &H00000080&
      Height          =   300
      Left            =   100
      TabIndex        =   11
      Top             =   888
      Width           =   5676
   End
   Begin CommandButton cmRequest
      Caption         =   "Request"
      Enabled         =   0   'False
      Height          =   276
      Left            =   6240
      TabIndex        =   10
      Top             =   576
      Width           =   1236
   End
   Begin ComboBox cbDDE_Item
      BackColor       =   &H00FFFFFF&
      Enabled         =   0   'False
      Height          =   288
      Left            =   3600
      TabIndex        =   2
      Top             =   600
      Width           =   2556
   End
   Begin ComboBox cbDDE_Topic
      BackColor       =   &H00FFFFFF&
      Enabled         =   0   'False
      Height          =   288
      Left            =   1920
      TabIndex        =   1
      Top             =   600
      Width           =   1572
   End
   Begin ComboBox cbDDE_App
      BackColor       =   &H00FFFFFF&
      Height          =   288
      Left            =   100
      TabIndex        =   0
      Top             =   600
      Width           =   1692
   End
   Begin CommandButton cmQuit
      Caption         =   "Quit"
      Height          =   276
      Left            =   6240
      TabIndex        =   4
      Top             =   96
      Width           =   1236
   End
   Begin Label txItem
      BackColor       =   &H00FFFFFF&
      Caption         =   "Item"
      Height          =   255
      Left            =   3600
      TabIndex        =   8
      Top             =   360
      Width           =   1095
   End
   Begin Label txTopic
      BackColor       =   &H00FFFFFF&
      Caption         =   "Topic"
      Height          =   255
      Left            =   1920
      TabIndex        =   7
      Top             =   360
      Width           =   1095
   End
   Begin Label txApplication
      BackColor       =   &H00FFFFFF&
      Caption         =   "Application"
      Height          =   255
      Left            =   100
      TabIndex        =   6
      Top             =   360
      Width           =   1335
   End
   Begin Menu mnFile
      Caption         =   "&File"
      Begin Menu miFileEdit
         Caption         =   "&Edit INI File"
      End
      Begin Menu miFileExit
         Caption         =   "E&xit"
      End
   End
   Begin Menu mnSave
      Caption         =   "&Save"
      Index           =   0
      Begin Menu miSaveApp
         Caption         =   "&Application"
      End
      Begin Menu miSaveTopic
         Caption         =   "&Topic"
      End
      Begin Menu miSaveItem
         Caption         =   "&Item"
      End
      Begin Menu miBar1
         Caption         =   "-"
      End
      Begin Menu miSaveExecute
         Caption         =   "&Execute"
      End
      Begin Menu miBar2
         Caption         =   "-"
      End
      Begin Menu miSavePoke
         Caption         =   "&Poke"
      End
   End
   Begin Menu mnHelp
      Caption         =   "&Help"
      Begin Menu miHelpAbout
         Caption         =   "&About"
      End
   End
DefInt A-X
Const NO_APP = 282
Const MULTIPLE_APPS = 283
Const WRONG_DATA_TYPE = 285
Const WM_USER = &H400
Const LB_RESETCONTENT = WM_USER + 5
Const CB_RESETCONTENT = WM_USER + 11
Dim DDEApp As String
Dim DDETopic As String
Dim DDEItem As String
Dim ValidLink As Integer
Dim app As String * 100
Dim exec As String * 200
Dim item As String * 100
Dim Topic As String * 100
Dim clipname As String * 40
Const INIFILE$ = "DDE_VB.INI"
Const INI_APPS$ = "Applications"
Dim HelpFilePath$
Dim CR$
Dim LF$
Dim NL$
Dim TB$
Sub cbDDE_App_Change ()
    cbDDE_Topic.Enabled = True
    cbDDE_Topic.text = ""
    cbDDE_Item.Enabled = False
    cbDDE_Item.text = ""
    cmDisconnect_click
End Sub
Sub cbDDE_App_DropDown ()
    ClearComboBox cbDDE_App
    Count% = GetPrivateProfileInt("Applications", "Apps", 0, INIFILE$)
    ReDim arIniApps(Count%)
    For i% = 1 To Count%
        zBuff% = GetPrivateProfileString("Applications", "App" + LTrim$(Str$(i%)), "none", app, 255, INIFILE$)
        arIniApps(i% - 1).AppName = LTrim$(RTrim$(Left$(app, zBuff%)))
        cbDDE_App.AddItem arIniApps(i% - 1).AppName
    Next
    cbDDE_Topic.Enabled = True
    cbDDE_Topic.text = ""
    cbDDE_Item.Enabled = False
    cbDDE_Item.text = ""
End Sub
Sub cbDDE_App_GotFocus ()
    tbStatus.text = "Select / Enter Application name to connect to..."
End Sub
Sub cbDDE_App_LostFocus ()
    tbStatus.text = ""
End Sub
Sub cbDDE_Item_DropDown ()
    ClearComboBox cbDDE_Item
    cmRequest.Enabled = True
    Topic = cbDDE_Topic.text
    Count2% = GetPrivateProfileInt(app, "Items", 0, INIFILE$)
    ReDim arItems(Count2%)
    For ii% = 1 To Count2%
        zBuff% = GetPrivateProfileString(app, "Item" + LTrim$(Str$(ii%)), "none", item, 255, INIFILE$)
        arItems(ii% - 1).item = LTrim$(RTrim$(Left$(item, zBuff%)))
        cbDDE_Item.AddItem arItems(ii% - 1).item
    Next
End Sub
Sub cbDDE_Item_GotFocus ()
    tbStatus.text = "Select / Enter the Item to get (cannot be blank)..."
End Sub
Sub cbDDE_Item_LostFocus ()
    tbStatus.text = ""
End Sub
Sub cbDDE_Topic_Change ()
    cbDDE_Item.Enabled = True
    cmRequest.Enabled = True
End Sub
Sub cbDDE_Topic_DropDown ()
    ClearComboBox cbDDE_Topic
    cbDDE_Item.Enabled = True
    cmRequest.Enabled = True
    app = cbDDE_App.text
    Count2% = GetPrivateProfileInt(app, "Topics", 0, INIFILE$)
    ReDim arTopics(Count2%)
    For i% = 1 To Count2%
        zBuff% = GetPrivateProfileString(app, "Topic" + LTrim$(Str$(i%)), "none", Topic, 255, INIFILE$)
        arTopics(i% - 1).Topic = LTrim$(RTrim$(Left$(Topic, zBuff%)))
        cbDDE_Topic.AddItem arTopics(i% - 1).Topic
    Next
End Sub
Sub cbDDE_Topic_GotFocus ()
    tbStatus.text = "Select / Enter Topic name (e.g. SYSTEM)..."
End Sub
Sub cbDDE_Topic_LostFocus ()
    tbStatus.text = ""
End Sub
Sub cbExecute_DropDown ()
    ClearComboBox cbExecute
    app = cbDDE_App.text
    Count% = GetPrivateProfileInt(app, "Executes", 0, INIFILE$)
    ReDim arExecutes(Count%)
    For i% = 1 To Count%
        zBuff% = GetPrivateProfileString(app, "Execute" + LTrim$(Str$(i%)), "none", exec, 255, INIFILE$)
        arExecutes(i% - 1).Instruction = LTrim$(RTrim$(Left$(exec, zBuff%)))
        cbExecute.AddItem arExecutes(i% - 1).Instruction
    Next

End Sub
Sub cbPoke_DropDown ()
    ClearComboBox cbPoke
    app = cbDDE_App.text
    Count% = GetPrivateProfileInt(app, "Pokes", 0, INIFILE$)
    ReDim arPokes(Count%)
    For i% = 1 To Count%
        zBuff% = GetPrivateProfileString(app, "Poke" + LTrim$(Str$(i%)), "none", exec, 255, INIFILE$)
        arPokes(i% - 1).Instruction = LTrim$(RTrim$(Left$(exec, zBuff%)))
        cbPoke.AddItem arPokes(i% - 1).Instruction
    Next
End Sub
Sub ClearComboBox (ctrl As Control)
    temp$ = ctrl.text
    hWndOld% = GetFocus()
    hWindow% = GetParent(GetFocus())
    x% = SendMessage(hWindow%, CB_RESETCONTENT, 0, 0)
    x% = PutFocus(hWndOld%)
    ctrl.text = temp$
End Sub
Sub ClearListBox (ctrl As Control)
  hWndOld% = GetFocus()
  ctrl.SetFocus
  x = SendMessage(GetFocus(), LB_RESETCONTENT, 0, 0)
  Suc% = PutFocus(hWndOld%)
End Sub
Sub cmClipboard_Click ()
    handle% = DDE_VB.hWnd
    x% = OpenClipboard(handle%)
    c% = CountClipboardFormats()
    z% = 0
    clipname = ""
    tbText.text = "CountClipboardFormats =" + Str$(c%) + NL$ + NL$
    For i% = 1 To c%
        z% = EnumClipboardFormats(z%)
        y% = GetClipboardFormatName(z%, clipname, Len(clipname))
        Select Case z%
            Case -16369 To -12289 ' "Private" formats &H200 to &H2FF
                clipname = "(Private)" + TB$ + Left$(clipname, InStr(clipname, Chr$(0)) - 1)
            Case -12273 To -8193  ' "GDIOBJ" formats  &H300 to &H3FF
                clipname = "(GDIOBJ)" + TB$ + Left$(clipname, InStr(clipname, Chr$(0)) - 1)
            Case 1                ' CF_TEXT
                clipname = "(Built In)" + TB$ + "CF_TEXT"
            Case 2                ' CF_BITMAP
                clipname = "(Built In)" + TB$ + "CF_BITMAP"
            Case 3                ' CF_METAFILE
                clipname = "(Built In)" + TB$ + "CF_METAFILE"
            Case 4                ' CF_SYLK
                clipname = "(Built In)" + TB$ + "CF_SYLK"
            Case 5                ' CF_DIF
                clipname = "(Built In)" + TB$ + "CF_DIF"
            Case 6                ' CF_TIFF
                clipname = "(Built In)" + TB$ + "CF_TIFF"
            Case 7                ' CF_OEMTEXT
                clipname = "(Built In)" + TB$ + "CF_OEMTEXT"
            Case 8                ' CF_DIB
                clipname = "(Built In)" + TB$ + "CF_DIB"
            Case 9                ' CF_PALETTE
                clipname = "(Built In)" + TB$ + "CF_DIB"
            Case 128              ' CF_OWNERDISPLAY = &H80
                clipname = "(Built In)" + TB$ + "CF_OWNERDISPLAY"
            Case 129              ' CF_DSPTEXT = &H81
                clipname = "(Built In)" + TB$ + "CF_DSPTEXT"
            Case 130              ' CF_DSPBITMAP = &H82
                clipname = "(Built In)" + TB$ + "CF_DSPBITMAP"
            Case 131              ' CF_DSPMETAFILEPICT = &H83
                clipname = "(Built In)" + TB$ + "CF_DSPMETAFILEPICT"
            Case Else
                clipname = "(Unknown)"
        End Select
        tbText.text = tbText.text + Str$(z%) + TB$ + clipname + NL$
    Next
    x% = CloseClipboard()
End Sub
Sub cmDisconnect_click ()
    MousePointer = 11
    On Error GoTo cmDisconnectError
    tbDDE.LinkMode = NONE
    tbError.text = ""
    tbText.text = ""
    cbExecute.text = ""
    cbPoke.text = ""
    cmRequest.Caption = "Connect"
    cmDisconnect.Visible = False
    cmRequest.Enabled = False
    cmExecute.Enabled = False
    cbExecute.Enabled = False
    cmPoke.Enabled = False
    cbPoke.Enabled = False
    MousePointer = 0
    Exit Sub
cmDisconnectError:
    Call DDE_Error(Err)
    Resume
End Sub
Sub cmExecute_Click ()
    On Error GoTo cmExecuteError
    tbError.text = ""
    tbDDE.LinkExecute cbExecute.text
    Exit Sub
cmExecuteError:
    Call DDE_Error(Err)
    Exit Sub
End Sub
Sub cmPoke_Click ()
    On Error GoTo cmPokeError
    tbError.text = ""
    tbDDE.text = cbPoke.text
    tbDDE.LinkPoke
    Exit Sub
cmPokeError:
    Call DDE_Error(Err)
    Exit Sub
End Sub
Sub CmQuit_Click ()
    MousePointer = 11
    On Error GoTo cmQuitError
    tbDDE.LinkMode = NONE
    Unload DDE_VB
    End
    Exit Sub
cmQuitError:
    Call DDE_Error(Err)
    Resume
End Sub
Sub cmReqSave_Click ()
    ' Check for valid link first
    ' If App doesn't exist in array then
        ' Add to Apps
    ' If Topic doesn't exist in array then
        ' Add to Topics
    ' If Item doesn't exist in array then
        ' Add to Items
    ReDim arIniApps(Count%)
    For i% = 1 To Count%
        zBuff% = GetPrivateProfileString("Applications", "App" + LTrim$(Str$(i%)), "none", app, 255, INIFILE$)
        arIniApps(i% - 1).AppName = LTrim$(RTrim$(Left$(app, zBuff%)))
        cbDDE_App.AddItem arIniApps(i% - 1).AppName
    Next
    Count% = GetPrivateProfileInt("Applications", "Apps", 0, INIFILE$) + 1
    action% = WritePrivateProfileString("Applications", "Apps", Str$(Count%), INIFILE$)
    sBuff$ = cbDDE_App.text
    zBuff% = WritePrivateProfileString("Applications", "App" + LTrim$(Str$(Count%)), sBuff$, INIFILE$)
    Count2% = GetPrivateProfileInt(app, "Topics", 0, INIFILE$)
    ReDim arTopics(Count2%)
    For i% = 1 To Count2%
        zBuff% = GetPrivateProfileString(app, "Topic" + LTrim$(Str$(i%)), "none", Topic, 255, INIFILE$)
        arTopics(i% - 1).Topic = LTrim$(RTrim$(Left$(Topic, zBuff%)))
        cbDDE_Topic.AddItem arTopics(i% - 1).Topic
    Next
End Sub
Sub CmRequest_Click ()
Dim ErrReq As Integer
    On Error GoTo cmRequestError
    tbError.text = ""
    Select Case cmRequest.Caption
        Case "Connect"
            DDEApp = cbDDE_App.text
            DDETopic = cbDDE_Topic.text
            DDEItem = cbDDE_Item.text
            MakeLink ValidLink, tbDDE, DDEApp, DDETopic, DDEItem
            Select Case ValidLink
                Case True
                Case False
                    Exit Sub
            End Select
            cmRequest.Caption = "Request"
            cmDisconnect.Visible = True
            cmExecute.Enabled = True
            cbExecute.Enabled = True
            cmPoke.Enabled = True
            cbPoke.Enabled = True
        Case "Request"
            tbDDE.LinkItem = cbDDE_Item.text
            tbDDE.LinkRequest
            StuffBox tbText, tbDDE
        Case Else
    End Select
    Exit Sub
cmRequestError:
    Call DDE_Error(Err)
    Exit Sub
End Sub
Sub DDE_Error (errVal)
    ErrReq = errVal
    DDE_VB.tbError.text = DecodeError(ErrReq)
    tbError.Refresh
End Sub
Sub Form_Load ()
    Initialize
    cmExecute.Enabled = False
    cbExecute.Enabled = False
    cmPoke.Enabled = False
    cbPoke.Enabled = False
    cmRequest.Caption = "Connect"
    FilePath$ = Space$(128)
    hModule% = GetClassWord(hWnd, GCW_HMODULE)
    zBuff% = GetModuleFileName(hModule%, FilePath$, 127)
    sBuff$ = Left$(FilePath$, z%)
End Sub
Sub Initialize ()
    ' Set general constants that cannot be declared:
    CR$ = Chr$(13)
    LF$ = Chr$(10)
    NL$ = Chr$(13) + Chr$(10)
    TB$ = Chr$(9)
End Sub
Sub MakeLink (Link As Integer, Window As Control, app As String, Topic As String, item As String)
Dim msg As String
Dim handle As Long
Dim ErrCon As Integer
    On Error GoTo MakeLinkError
    handle = GetModuleHandle(UCase$(app + ".EXE"))
    While GetModuleHandle(UCase$(app + ".EXE")) = 0
        msg = "No application responded to DDE initiate.  Attempt to start " + app + " ?"
        If MsgBox(msg, MB_ICONQUESTION + MB_OKCANCEL) = IDOK Then
            Link = Shell(app + ".EXE")
        Else
            Link = USER_CANCELED
            Exit Sub
        End If
    Wend
    'While GetModuleUsage(handle) > 1
        ' Multiple apps running
    'Wend
    Window.LinkTopic = app + "|" + Topic
    Window.LinkItem = item
    Window.LinkMode = COLD
    Window.LinkRequest
    StuffBox tbText, tbDDE
    Link = True
    'Select Case ValidLink
    '    Case SUCCESS
    '        CmConnect.Caption = "&Disconnect"
    '        ValidLink = True
    '        tbDDE.Visible = True
    '        tbDDE.LinkRequest
    '    Case USER_CANCELED, NO_APP, MULTIPLE_APPS
    '        BreakLink
    '        Exit Sub
    '    Case Else
    '        Stop
    'End Select
    Exit Sub
MakeLinkError:
    Call DDE_Error(Err)
    Exit Sub
End Sub
Sub miFileEdit_Click ()
    run = Shell("NOTEPAD C:\WINDOWS\DDE_VB.INI", 1)
End Sub
Sub miFileExit_Click ()
    MousePointer = 11
    On Error GoTo miFileExitError
    tbDDE.LinkMode = NONE
    Unload DDE_VB
    End
    Exit Sub
miFileExitError:
    Call DDE_Error(Err)
    Resume
End Sub
Sub miHelpAbout_Click ()
    AboutForm.Show
End Sub
Sub miSaveApp_Click ()
    Count% = GetPrivateProfileInt("Applications", "Apps", 0, INIFILE$) + 1
    action% = WritePrivateProfileString("Applications", "Apps", Str$(Count%), INIFILE$)
    sBuff$ = cbDDE_App.text
    zBuff% = WritePrivateProfileString("Applications", "App" + LTrim$(Str$(Count%)), sBuff$, INIFILE$)
End Sub
Sub miSaveExecute_Click ()
    app = cbDDE_App.text
    Count% = GetPrivateProfileInt(app, "Executes", 0, INIFILE$) + 1
    action% = WritePrivateProfileString(app, "Executes", Str$(Count%), INIFILE$)
    sBuff$ = cbExecute.text
    action% = WritePrivateProfileString(app, "Execute" + LTrim$(Str$(Count%)), sBuff$, INIFILE$)
End Sub
Sub miSaveItem_Click ()
    app = cbDDE_App.text
    Count% = GetPrivateProfileInt(app, "Items", 0, INIFILE$) + 1
    action% = WritePrivateProfileString(app, "Items", Str$(Count%), INIFILE$)
    sBuff$ = cbDDE_Item.text
    action% = WritePrivateProfileString(app, "Item" + LTrim$(Str$(Count%)), sBuff$, INIFILE$)
End Sub
Sub miSavePoke_Click ()
    app = cbDDE_App.text
    Count% = GetPrivateProfileInt(app, "Pokes", 0, INIFILE$) + 1
    action% = WritePrivateProfileString(app, "Pokes", Str$(Count%), INIFILE$)
    sBuff$ = cbPoke.text
    action% = WritePrivateProfileString(app, "Poke" + LTrim$(Str$(Count%)), sBuff$, INIFILE$)
End Sub
Sub miSaveTopic_Click ()
    app = cbDDE_App.text
    Count% = GetPrivateProfileInt(app, "Topics", 0, INIFILE$) + 1
    action% = WritePrivateProfileString(app, "Topics", Str$(Count%), INIFILE$)
    sBuff$ = cbDDE_Topic.text
    action% = WritePrivateProfileString(app, "Topic" + LTrim$(Str$(Count%)), sBuff$, INIFILE$)
End Sub
Sub StuffBox (tbText As Control, tbDDE As Control)
Dim sBuff As String * 250
b% = 1
If InStr(tbDDE.text, LF$) = 0 Then
    For x% = 1 To Len(tbDDE.text)
        If Mid$(tbDDE.text, x%, 1) = TB$ Then
            Mid$(sBuff, b%, 2) = NL$
            b% = b% + 1
        Else
            Mid$(sBuff, b%, 1) = Mid$(tbDDE.text, x%, 1)
        End If
        b% = b% + 1
    Next
    tbText.text = sBuff
    tbText.text = tbDDE.text
End If
End Sub